home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 19 / madtrb11.zip / SHEETLIB.INC < prev    next >
Text File  |  1985-11-28  |  8KB  |  434 lines
  1.  
  2.  
  3.  
  4. procedure incr(var i : integer);
  5.  
  6. begin
  7.   i := i + 1;
  8. end;
  9.  
  10.  
  11.  
  12.  
  13. procedure get_screen(var buffer : imagetype);
  14.  
  15. begin
  16.     if crtmode = 7 then buffer := monobuffer else
  17.             buffer := colorbuffer;
  18. end;
  19.  
  20.  
  21.  
  22. procedure put_screen(var buffer : imagetype);
  23.  
  24. begin
  25.     if crtmode = 7 then monobuffer := buffer else
  26.             colorbuffer := buffer;
  27. end;
  28.  
  29.  
  30.  
  31. procedure decr(var i : integer);
  32.  
  33. begin
  34.   i := i - 1;
  35. end;
  36.  
  37.  
  38.  
  39.  
  40.  
  41. procedure init_var;
  42.  
  43.  
  44. var
  45.   i : integer;
  46.  
  47.  
  48. begin
  49.   wp_index := 0;
  50.   escape := #27;
  51.   retrn  := #13;
  52.   up     := #9;
  53.   down   := #10;
  54.   left   := #11;
  55.   right  := #12;
  56.   home   := #14;
  57.   endd   := #15;
  58.   pgup   := #16;
  59.   pgdn   := #17;
  60.   f1     := #1;
  61.   f2     := #2;
  62.   f3     := #3;
  63.   f4     := #4;
  64.   f5     := #5;
  65.   f6     := #6;
  66.   f7     := #7;
  67.   f8     := #8;
  68.   sheet_corn[0] := 13;
  69.   sheet_corn[1] :=  2;
  70.   sheet_corn[2] := 77;
  71.   sheet_corn[3] := 11;
  72.   graph_corn[0] :=  2;
  73.   graph_corn[1] := 13;
  74.   graph_corn[2] := 75;
  75.   graph_corn[3] := 24;
  76.   rp_mode       := false;
  77.   for i := 0 to 1 do 
  78.     begin
  79.       range.top[i] := 0;
  80.       range.bottom[i] := 0;
  81.     end;
  82.   point_mode    := o;
  83.   scale := 0;
  84.   ar_sz := 0;
  85. end;   { procedure init_var }
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94. procedure putcharv(x,y : integer; ch : char);
  95. begin
  96.     if crtmode = 7 then 
  97.       begin
  98.          monobuffer[y,x,char_byte] := ch;
  99.          monobuffer[y,x,attr_byte] := chr(112);
  100.       end
  101.     else
  102.       begin   
  103.          colorbuffer[y,x,char_byte] := ch;
  104.          colorbuffer[y,x,attr_byte] := chr(112);
  105.       end; 
  106. end;
  107.  
  108.  
  109. procedure putchar(x,y : integer; ch : char);
  110. begin
  111.     if crtmode = 7 then 
  112.       begin
  113.          monobuffer[y,x,char_byte] := ch;
  114.          monobuffer[y,x,attr_byte] := chr(7);
  115.       end
  116.     else
  117.       begin   
  118.          colorbuffer[y,x,char_byte] := ch;
  119.          colorbuffer[y,x,attr_byte] := chr(7);
  120.       end; 
  121. end;
  122.  
  123.  
  124.  
  125.  
  126.  
  127. PROCEDURE PUTSTRING(xcoord, ycoord : integer;s :lst);
  128.  
  129. var
  130.   i :integer;
  131.  
  132. begin
  133.   for i := 1 to length(s) do putchar((xcoord + i - 1), ycoord,s[i]);
  134. end;   { PUTSTRING }    
  135.  
  136. PROCEDURE PUTSTRINGv(xcoord, ycoord : integer;s :lst);
  137.  
  138. var
  139.   i :integer;
  140.  
  141. begin
  142.   for i := 1 to length(s) do putcharv((xcoord + i - 1), ycoord,s[i]);
  143. end;   { PUTSTRING }    
  144.  
  145.  
  146.  
  147.  
  148. PROCEDURE INVERSE;
  149.  { sets current screen attribute (used by PUTSTRING) to inverse status }
  150.  
  151. BEGIN
  152.  
  153.    
  154.    textcolor(black);
  155.    textbackground(white);
  156.  
  157. END;   { inverse }
  158.  
  159.  
  160.  
  161.  
  162.  
  163. PROCEDURE NORMAL;
  164.  { sets the current screen attribute (used by PUTSTRING) to normal status }
  165.  
  166. BEGIN
  167.  
  168.    
  169.    textcolor(white);
  170.    textbackground(black);
  171.  
  172. END;   { normal }
  173.  
  174.  
  175.  
  176. PROCEDURE DRAWBOX(col, line, horiz, vert : integer);
  177.  
  178. VAR
  179.    I                    : INTEGER;
  180.    S                    : LST;
  181.    ul,ur,ll,lr,h,v      : char;
  182.  
  183. BEGIN  { DRAWBOX }
  184.  
  185.    UL := CHR(218); {┌}
  186.    UR := CHR(191); {┐}
  187.    LL := CHR(192); {└}
  188.    LR := CHR(217); {┘ }
  189.    H  := CHR(196); {─ }
  190.    V  := CHR(179); {│ }
  191.  
  192.  
  193.    
  194.    s := '';
  195.    for i := 1 to horiz do s:= concat(s,h);
  196.    
  197.    s := concat(ul,s,ur);
  198.    putstring(col,line,s);
  199.    
  200.    
  201.     { DRAW RIGHT VERTICAL LINE }
  202.    FOR I := 1 TO (VERT + 1) DO
  203.         begin
  204.           putchar(col,(line + i),v);
  205.           putchar((col + horiz + 1),(line + i),v);
  206.         end;
  207.    
  208.    
  209.     { DRAW BOTTOM LINE }
  210.    
  211.    s := '';
  212.    for i := 1 to horiz do s:= concat(s,h);
  213.    
  214.    s := concat(ll,s,lr);
  215.    putstring(col,(line + vert + 1),s);
  216.  
  217.  
  218. END;   { DRAWBOX }
  219.  
  220.  
  221.  
  222.  
  223.  
  224. procedure put_box(text1, text2:lst);
  225.  
  226. const
  227.    maxlength  = 75;
  228.  
  229. begin
  230.   drawbox(0,20,77,2);
  231.   if (length(text1) > maxlength) then text1 := copy(text1,1,75);
  232.   if (length(text2) > maxlength) then text2 :=  copy(text2,1,75);
  233.   putstring(2,21,text1);
  234.   putstring(2,22,text2);
  235. end;  { put_box }
  236.  
  237.  
  238.  
  239.  
  240.  
  241. PROCEDURE   SET_CURSOR_TYPE  (var start: byte; var  stop : byte);
  242. { use byte type as parameter so number is straight binary }
  243.  
  244. var
  245.   recpack : regpack;
  246.  
  247. begin
  248.  
  249.  with recpack do
  250.   begin
  251.     ax := 1 shl 8;   { set cursor type call }
  252.     cx := start shl 8 + stop;  { start goes into bits 4-0 of CH }
  253.   end;
  254.  
  255.   intr($10,recpack);
  256. end;   { set_cursor_type }
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263. PROCEDURE   CURRENT_VIDEO_STATE
  264.        (var page  : byte;     { parameter is modified }
  265.         var mode  : byte;     { parameter is modified }
  266.         var width : byte);    { parameter is modified }
  267.  
  268. var
  269.   recpack : regpack;
  270.  
  271. begin
  272.   with recpack do ax := 15 shl 8; {  video state request }
  273.   intr($10,recpack);              {  int hex 10 is video services }
  274.   with recpack do
  275.     begin
  276.       mode :=  ax; { actually in AL }
  277.       width := swap(ax);  { AH }
  278.       page  := swap(bx);  { BH }
  279.     end;
  280. end;   { current_video_state }
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290. PROCEDURE RESET_CURSOR;                           { internal to SAFELIB.IMP }
  291.  
  292.  { turns cursor back to underline }
  293.  
  294. VAR
  295.    PAGE,MODE,WIDTH,START,STOP : byte;
  296.  
  297. BEGIN  { reset_cursor }
  298.  
  299. CURRENT_VIDEO_STATE(PAGE,MODE,WIDTH); { find out what kind of monitor this is }
  300.  
  301. IF MODE = 7 THEN BEGIN                { monochrome }
  302.    START := 12;
  303.    STOP := 13;
  304. END
  305. ELSE BEGIN
  306.    START := 7;
  307.    STOP := 7;
  308. END;  (* if *)
  309. SET_CURSOR_TYPE(START,STOP);
  310.  
  311. END;   { reset_cursor }
  312.  
  313. PROCEDURE SET_CURSOR;                           { internal to SAFELIB.IMP }
  314.  
  315.  { turns cursor into large white block }
  316.  
  317. VAR
  318.    PAGE,MODE,WIDTH,START,STOP : byte;
  319.  
  320. BEGIN  { set_cursor }
  321.  
  322. CURRENT_VIDEO_STATE(PAGE,MODE,WIDTH); { find out what kind of monitor this is }
  323. START := 0;                           { cursor_start will be top line }
  324. IF MODE = 7 THEN STOP := 13           { if monochrome, last line is 13 }
  325. ELSE STOP := 7;                       { else color or graphice, last line = 7 }
  326. SET_CURSOR_TYPE(START,STOP);          { set it }
  327.  
  328. END;   { set_cursor }
  329.  
  330.  
  331.  
  332.  
  333. procedure zero_cursor;
  334.  
  335. var
  336.   a,b : byte;
  337.  
  338. begin
  339.   reset_cursor;
  340. end;   { zereo_cursor }
  341.  
  342.  
  343.  
  344.  
  345. function getchar(okset : setofchar; cursoron : boolean): char;
  346.  
  347.  
  348. const
  349.    prefix = #0;   { Turbo's version of chr(0) }
  350.    BELL   = #7;
  351.  
  352.  
  353. var
  354.   ch : char;
  355.   good   : boolean;
  356.  
  357.  
  358. function getchar_detail:char;   {does the DOS call }
  359.  
  360.   type
  361.    regpack = record
  362.               ax,bx,cx,dx,bp,si,ds,es,flags: integer;
  363.             end;
  364.  
  365.   var
  366.    recpack : regpack;
  367.  
  368.   begin
  369.      recpack.ax := $07 shl 8;
  370.      { puts the Hex 07 call (KB input) into AH }
  371.      MsDos(recpack);
  372.      getchar_detail := chr(lo(recpack.ax));
  373.      { keystroke is returned in AL -- this seems to read it ok }
  374.  
  375.   end;  { getchar_detail }
  376.  
  377.  
  378. begin
  379.   if (cursoron) then set_cursor;
  380.  
  381.  
  382.   REPEAT
  383.    ch := getchar_detail;
  384.    IF CH = PREFIX THEN BEGIN     { prefixed key }
  385.       ch := getchar_detail; { get next key that is sitting there }
  386.       CASE ORD(CH) OF
  387.          75 : ch := LEFT;
  388.          77 : CH := RIGHT;
  389.          72 : CH := UP;
  390.          80 : CH := DOWN;
  391.          59 : ch := f1;
  392.          60 : ch := f2;
  393.          61 : ch := f3;   {á}
  394.          62 : ch := f4;   { í }
  395.          63 : ch := f5;   { ó }
  396.          64 : ch := f6;    
  397.          65 : ch := f7;
  398.          66 : ch := f8;
  399. {        68 : ch := f10;    }
  400.          71 : ch := home;
  401.          73 : ch := pgup;
  402.          79 : ch := endd;
  403. {        81 : ch := pgdn;
  404.          84 : ch := f11;
  405.          85 : ch := f12;
  406.          86 : ch := f13;
  407.          87 : ch := f14;
  408.          88 : ch := f15;
  409. }
  410.          else CH := CHR(0);
  411.       END;  { case }
  412.    END;  { if }
  413.  
  414.   good := ch in okset;
  415.   if not good then write(bell)
  416.   else if (ord(ch) >= 32) and (cursoron) then write(ch);
  417.  
  418. UNTIL good;
  419.  
  420. getchar := ch;
  421.   if (cursoron) then
  422. reset_cursor;
  423.  
  424. end; { function getchar }
  425.  
  426.  
  427.                                     { PC Specific }
  428.  
  429. {  function str2real(str:numstr):real 
  430.  
  431.      begin end;
  432. }
  433.  
  434.